home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / DELPHI32 / BUTTONS / XTOOLBTN / XGIF.PAS < prev    next >
Pascal/Delphi Source File  |  1996-04-27  |  25KB  |  687 lines
  1. unit xGif; {$D-}
  2.  
  3. {Freeware GIF image component
  4.  
  5. Based on GifUtl.pas (c)1993 Sean Wenzel     Compuserve 71736,1245
  6. Converted to Delphi by Richard Dominelli     RichardA_Dominelli@mskcc.org
  7. Converted to Delphi 2 and made into an
  8. image component by Richard Shotbolt        Compuserve 100327,2305
  9.  
  10. enhance component as a descendant from          www.fabula.com
  11. TBitmap and register the GIF file format        stefc@fabula.com
  12. so it's ideal for include it in the xTools      CompuServe 100023,275
  13. Now you can Load bitmaps from
  14. by Stefan B÷ther
  15.  
  16. Left Open :
  17.   - Also store the format via SaveToStream override
  18.     so the GIF format can be used in blob formats
  19.     also !
  20.   - GIF 89a format not work propably 
  21.   - use real gif transarency for TransparentColor
  22.     property instead of lower-left pixel
  23.   - support of new PNG format
  24.  
  25. Before using the GIF format in any commercial
  26. application be sure you know the legal issuees for
  27. this format !!!
  28. }
  29.  
  30. interface
  31.  
  32. uses
  33.   Windows, Forms, SysUtils, Classes, Graphics;
  34.  
  35. type
  36.   TGifBitmap = class(TBitmap)
  37.   public
  38.     procedure LoadFromStream(Stream: TStream); override;
  39.   end;
  40.  
  41. type
  42.   EGifException = class(Exception)
  43.   end;
  44.  
  45. implementation
  46.  
  47. uses
  48.   Math; 
  49.  
  50. const
  51.   { image descriptor bit masks }
  52.   idLocalColorTable      = $80;      { set if a local color table follows }
  53.   idInterlaced           = $40;      { set if image is interlaced }
  54.   idSort                 = $20;      { set if color table is sorted }
  55.   idReserved             = $0C;      { reserved - must be set to $00 }
  56.   idColorTableSize       = $07;      { size of color table as above }
  57.   Trailer: byte          = $3B;      { indicates the end of the GIF data stream }
  58.   ExtensionIntroducer: byte = $21;
  59.   MAXSCREENWIDTH         = 800;
  60.   ImageSeparator: byte   = $2C;
  61.  
  62.   { logical screen descriptor packed field masks }
  63.   lsdGlobalColorTable = $80;    { set if global color table follows L.S.D. }
  64.   lsdColorResolution = $70;    { Color resolution - 3 bits }
  65.   lsdSort = $08;                    { set if global color table is sorted - 1 bit }
  66.   lsdColorTableSize = $07;    { size of global color table - 3 bits }
  67.                                         { Actual size = 2^value+1    - value is 3 bits }
  68.   BlockTerminator: byte = 0; { terminates stream of data blocks }
  69.   MAXCODES = 4095;                { the maximum number of different codes 0 inclusive }
  70.  
  71.   { error constants }
  72.   geNoError         =  0;  { no errors found }
  73.   geNoFile          =  1;  { gif file not found }
  74.   geNotGIF          =  2;  { file is not a gif file }
  75.   geNoGlobalColor   =  3;  { no Global Color table found }
  76.   geImagePreceded   =  4;  { image descriptor preceeded by other unknown data }
  77.   geEmptyBlock      =  5;  { Block has no data }
  78.   geUnExpectedEOF   =  6;  { unexpected EOF }
  79.   geBadCodeSize     =  7;  { bad code size }
  80.   geBadCode         =  8;  { Bad code was found }
  81.   geBitSizeOverflow =  9;  { bit size went beyond 12 bits }
  82.   geNoBMP           = 10;  { Could not make BMP file }
  83.  
  84.   ErrName: Array[1..10] of string = (
  85.     'GIF file not found',
  86.     'Not a GIF file',
  87.     'Missing color table',
  88.     'Bad data',
  89.     'No data',
  90.      'Unexpected EOF',
  91.     'Bad code size',
  92.     'Bad code',
  93.     'Bad bit size',
  94.         'Bad bitmap');
  95.  
  96. CodeMask: array[0..12] of Word = (  { bit masks for use with Next code }
  97.     0,
  98.     $0001, $0003,
  99.     $0007, $000F,
  100.     $001F, $003F,
  101.     $007F, $00FF,
  102.     $01FF, $03FF,
  103.     $07FF, $0FFF);
  104.  
  105. type
  106.   TDataSubBlock = packed record
  107.     Size: byte;     { size of the block -- 0 to 255 }
  108.     Data: array[1..255] of byte; { the data }
  109.   end;
  110.  
  111. type
  112.   THeader = packed record
  113.     Signature: array[0..2] of char; { contains 'GIF' }
  114.     Version: array[0..2] of char;   { '87a' or '89a' }
  115.   end;
  116.  
  117. TLogicalScreenDescriptor = packed record
  118.   ScreenWidth: word;              { logical screen width }
  119.   ScreenHeight: word;  { logical screen height }
  120.   PackedFields: byte;     { packed fields - see below }
  121.   BackGroundColorIndex: byte;     { index to global color table }
  122.   AspectRatio: byte;      { actual ratio = (AspectRatio + 15) / 64 }
  123. end;
  124.  
  125. type
  126.   TColorItem = packed record            { one item a a color table }
  127.     Red: byte;
  128.     Green: byte;
  129.     Blue: byte;
  130.   end;
  131.  
  132.   TColorTable = packed array[0..255] of TColorItem;    { the color table }
  133.  
  134. type
  135.   TImageDescriptor = packed record
  136.     Separator: byte;        { fixed value of ImageSeparator }
  137.     ImageLeftPos: word;     { Column in pixels in respect to left edge of logical screen }
  138.     ImageTopPos: word;    { row in pixels in respect to top of logical screen }
  139.     ImageWidth: word;        { width of image in pixels }
  140.     ImageHeight: word;     { height of image in pixels }
  141.     PackedFields: byte;    { see below }
  142.   end;
  143.  
  144. { other extension blocks not currently supported by this unit
  145.     - Graphic Control extension
  146.     - Comment extension           I'm not sure what will happen if these blocks
  147.     - Plain text extension        are encountered but it'll be interesting
  148.     - application extension }
  149.  
  150. type
  151.   TExtensionBlock = packed record
  152.     Introducer: byte;                               { fixed value of ExtensionIntroducer }
  153.     ExtensionLabel: byte;
  154.     BlockSize: byte;
  155.   end;
  156.  
  157.   PCodeItem = ^TCodeItem;
  158.   TCodeItem = packed record
  159.     Code1, Code2: byte;
  160.   end;
  161.  
  162. {===============================================================}
  163. {    Bitmap File Structs
  164. {===============================================================}
  165.  
  166. type
  167.   GraphicLine      = packed array [0..2048] of byte;
  168.   PBmLine         = ^TBmpLinesStruct;
  169.   TBmpLinesStruct = packed record
  170.     LineData  : GraphicLine;
  171.     LineNo    : Integer;
  172.   end;
  173.  
  174. type
  175.   { This is the actual gif object }
  176.   PGif = ^TGif;
  177.   TGif = class(TObject)
  178.   private
  179.     FStream             : TStream;                { the file stream for the gif file }
  180.     Header              : THeader;               { gif file header }
  181.     LogicalScreen       : TLogicalScreenDescriptor;  { gif screen descriptor }
  182.     GlobalColorTable    : TColorTable;             { global color table }
  183.     LocalColorTable     : TColorTable;             { local color table }
  184.     ImageDescriptor     : TImageDescriptor;          { image descriptor }
  185.     UseLocalColors      : boolean;        { true if local colors in use }
  186.     Interlaced          : boolean;                { true if image is interlaced }
  187.     LZWCodeSize         : Byte;                { minimum size of the LZW codes in bits }
  188.     ImageData           : TDataSubBlock;        { variable to store incoming gif data }
  189.     TableSize           : Word;                    { number of entrys in the color table }
  190.     BitsLeft,
  191.     BytesLeft           : Integer;    { bits left in byte - bytes left in block }
  192.     BadCodeCount        : word;              { bad code counter }
  193.     CurrCodeSize        : Integer;           { Current size of code in bits }
  194.     ClearCode           : Integer;              { Clear code value }
  195.     EndingCode          : Integer;             { ending code value }
  196.     Slot                : Word;                            { position that the next new code is to be added }
  197.     TopSlot             : Word;            { highest slot position for the current code size }
  198.     HighCode            : Word;        { highest code that does not require decoding }
  199.     NextByte            : Integer;    { the index to the next byte in the datablock array }
  200.     CurrByte            : Byte;          { the current byte }
  201.     DecodeStack         : array[0..MAXCODES] of byte; { stack for the decoded codes }
  202.     Prefix              : array[0..MAXCODES] of integer;                     { array for code prefixes }
  203.     Suffix              : array[0..MAXCODES] of integer;             { array for code suffixes }
  204.     LineBuffer          : GraphicLine; { array for buffer line output }
  205.     CurrentX,
  206.     CurrentY            : Integer;                                            { current screen locations }
  207.     Status              : Word;
  208.     InterlacePass       : byte;    { interlace pass number }
  209.     {Conversion Routine Vars}
  210.     BmHeader : TBitmapInfoHeader; {File Header for bitmap file}
  211.     ImageLines: TList; {Image data}
  212.     {Member Functions}
  213.     procedure ParseMem;
  214.     function NextCode: word;     { returns the next available code }
  215.     procedure Error(ErrCode: integer);
  216.     procedure InitCompressionStream;   { initializes info for decode }
  217.     procedure ReadSubBlock;  { reads a data subblock from the stream }
  218.     procedure CreateLine;
  219.     procedure CreateBitHeader; {Takes the gif header information and converts it to BMP}
  220.     procedure Decode;
  221.   public
  222.     constructor Create;
  223.     destructor Destroy; override;
  224.     procedure LoadFromStream(Stream: TStream);
  225.     procedure SaveToStream(Stream: TStream);
  226.   end;
  227.  
  228.  
  229. (*
  230.  
  231. function Power(A, N: real): real; { returns A raised to the power of N }
  232. begin
  233.   Power := exp(N * ln(A));
  234. end;
  235.  
  236. *)
  237.  
  238. { TGifBitmap }
  239.  
  240. procedure TGifBitmap.LoadFromStream(Stream: TStream);
  241. var
  242.   aBitmap : TBitmap;
  243.   aGif    : TGif;
  244.   aStream : TMemoryStream;
  245. begin
  246.   aGif := TGif.Create;
  247.   try
  248.     aGif.LoadFromStream(Stream);
  249.  
  250.     aStream:=TMemoryStream.Create;
  251.     try
  252.       aGif.SaveToStream(aStream);
  253.       aBitmap:=TBitmap.Create;
  254.       aBitmap.LoadFromStream(aStream);
  255.       Assign(aBitmap);
  256.     finally
  257.       aStream.Free;
  258.     end;
  259.   finally
  260.     aGif.Free;
  261.   end;
  262. end;
  263.  
  264. { TGif }
  265.  
  266. constructor TGif.Create;
  267. begin
  268.   FStream := nil;
  269.   ImageLines := TList.Create;
  270. end;
  271.  
  272. {------------------------------------------------------------------------------}
  273.  
  274. destructor TGif.Destroy;
  275. begin
  276.   ImageLines.Free;
  277.   inherited Destroy;
  278. end;
  279.  
  280. {------------------------------------------------------------------------------}
  281.  
  282. procedure TGif.LoadFromStream(Stream: TStream);
  283. begin
  284.   FStream:=Stream;
  285.   { Converts GIF file to bitstream }
  286.   ParseMem;
  287.   { Create the bitmap header info }
  288.   CreateBitHeader;
  289.   { Decode the GIF }
  290.   Decode;
  291. (*  WriteBitmapToStream; *)
  292. end;
  293.  
  294. {------------------------------------------------------------------------------}
  295.  
  296. {Raise exception with a message}
  297. procedure TGif.Error(ErrCode: integer);
  298. begin
  299.   raise EGifException.Create(ErrName[ErrCode]);
  300. end;
  301. {------------------------------------------------------------------------------}
  302.  
  303. procedure TGif.ParseMem;
  304. {Decodes the header and palette info}
  305. begin
  306.   FStream.Read(Header, sizeof(Header)); { read the header }
  307.   {Stupid validation tricks}
  308.   if Header.Signature <> 'GIF' then Error(geNotGif);  { is vaild signature }
  309.   {Decode the header information}
  310.   FStream.Read(LogicalScreen, sizeof(LogicalScreen));
  311.   if LogicalScreen.PackedFields and lsdGlobalColorTable = lsdGlobalColorTable then
  312.   begin
  313.     TableSize := Trunc(intPower(2,(LogicalScreen.PackedFields and lsdColorTableSize)+1));
  314.     FStream.Read(GlobalColorTable, TableSize*sizeof(TColorItem)); { read Global Color Table }
  315.   end else
  316.     Error(geNoGlobalColor);
  317.   {Done with Global Headers}
  318.   {Image specific headers}
  319.   FStream.Read(ImageDescriptor, sizeof(ImageDescriptor)); { read image descriptor }
  320.   {Decode image header info}
  321.   if ImageDescriptor.Separator <> ImageSeparator then   { verify that it is the descriptor }
  322.      Error(geImagePreceded);
  323.   {Check for local color table}
  324.   if ImageDescriptor.PackedFields and idLocalColorTable = idLocalColorTable then
  325.   begin                                                               { if local color table }
  326.     TableSize := Trunc(intPower(2,(ImageDescriptor.PackedFields and idColorTableSize)+1));
  327.     FStream.Read(LocalColorTable, TableSize*sizeof(TColorItem)); { read Local Color Table }
  328.     UseLocalColors := True;
  329.   end else
  330.     UseLocalColors := False;
  331.   {Check for interlaced}
  332.   if ImageDescriptor.PackedFields and idInterlaced = idInterlaced then
  333.   begin
  334.     Interlaced := true;
  335.     InterlacePass := 0;
  336.   end;
  337.  {End of image header stuff}
  338.  {Reset then Expand capacity of the Image Lines list}
  339.  ImageLines.Clear;
  340.  ImageLines.Capacity := ImageDescriptor.ImageHeight;
  341.  if (FStream = nil) then    { check for stream error }
  342.     Error(geNoFile);
  343. end;
  344.  
  345. {------------------------------------------------------------------------------}
  346.  
  347. procedure TGif.InitCompressionStream;
  348. begin
  349.   {InitGraphics;}                                   { Initialize the graphics display }
  350.   FStream.Read(LZWCodeSize, sizeof(byte));    { get minimum code size }
  351.   if not (LZWCodeSize in [2..9]) then         { valid code sizes 2-9 bits }
  352.      Error(geBadCodeSize);
  353.   CurrCodeSize := succ(LZWCodeSize); { set the initial code size }
  354.   ClearCode := 1 shl LZWCodeSize;    { set the clear code }
  355.   EndingCode := succ(ClearCode);     { set the ending code }
  356.   HighCode := pred(ClearCode);           { set the highest code not needing decoding }
  357.   BytesLeft := 0;                    { clear other variables }
  358.   BitsLeft := 0;
  359.   CurrentX := 0;
  360.   CurrentY := 0;
  361. end;
  362. {------------------------------------------------------------------------------}
  363.  
  364. procedure TGif.ReadSubBlock;
  365. begin
  366.   FStream.Read(ImageData.Size, sizeof(ImageData.Size)); { get the data block size }
  367.   if ImageData.Size = 0 then
  368.      Error(geEmptyBlock);                                    { check for empty block }
  369.   FStream.Read(ImageData.Data, ImageData.Size);     { read in the block }
  370.   NextByte := 1;                                 { reset next byte }
  371.   BytesLeft := ImageData.Size;                        { reset bytes left }
  372. end;
  373.  
  374. {------------------------------------------------------------------------------}
  375.  
  376. function TGif.NextCode: word; { returns a code of the proper bit size }
  377. begin
  378.   if BitsLeft = 0 then        { any bits left in byte ? }
  379.   begin                         { any bytes left }
  380.     if BytesLeft <= 0 then     { if not get another block }
  381.        ReadSubBlock;
  382.     CurrByte := ImageData.Data[NextByte];     { get a byte }
  383.     Inc(NextByte);                            { set the next byte index }
  384.     BitsLeft := 8;                            { set bits left in the byte }
  385.     Dec(BytesLeft);                           { decrement the bytes left counter }
  386.   end;
  387.   Result := CurrByte shr (8 - BitsLeft);            { shift off any previosly used bits}
  388.   while CurrCodeSize > BitsLeft do            { need more bits ? }
  389.     begin
  390.       if BytesLeft <= 0 then                        { any bytes left in block ? }
  391.          ReadSubBlock;                       { if not read in another block }
  392.       CurrByte := ImageData.Data[NextByte];     { get another byte }
  393.       inc(NextByte);                            { increment NextByte counter }
  394.       Result := Result or (CurrByte shl BitsLeft);    { add the remaining bits to the return value }
  395.       BitsLeft := BitsLeft + 8;              { set bit counter }
  396.       Dec(BytesLeft);                         { decrement bytesleft counter }
  397.     end;
  398.   BitsLeft := BitsLeft - CurrCodeSize;  { subtract the code size from bitsleft }
  399.   Result := Result and CodeMask[CurrCodeSize];{ mask off the right number of bits }
  400. end;
  401.  
  402. {------------------------------------------------------------------------------}
  403.  
  404. procedure TGif.Decode;  { this procedure actually decodes the GIF image }
  405. var
  406.   SP: integer; { index to the decode stack }
  407.  
  408.   { local procedure that decodes a code and puts it on the decode stack }
  409.   procedure DecodeCode(var Code: word);
  410.   begin
  411.     while Code > HighCode do { rip thru the prefix list placing suffixes }
  412.     begin                    { onto the decode stack }
  413.       DecodeStack[SP] := Suffix[Code]; { put the suffix on the decode stack }
  414.       inc(SP);                         { increment decode stack index }
  415.       Code := Prefix[Code];            { get the new prefix }
  416.     end;
  417.     DecodeStack[SP] := Code;                { put the last code onto the decode stack }
  418.     Inc(SP);                                { increment the decode stack index }
  419.   end;
  420.  
  421. var
  422.   TempOldCode, OldCode: word;
  423.   BufCnt: word;    { line buffer counter }
  424.   Code, C: word;
  425.   CurrBuf: word;    { line buffer index }
  426.   MaxVal: boolean;
  427. begin
  428.   InitCompressionStream;    { Initialize decoding paramaters }
  429.   OldCode := 0;
  430.   SP := 0;
  431.   BufCnt := ImageDescriptor.ImageWidth; { set the Image Width }
  432.   CurrBuf := 0;
  433.   MaxVal := False;
  434.   C := NextCode;                { get the initial code - should be a clear code }
  435.   while C <> EndingCode do  { main loop until ending code is found }
  436.   begin
  437.     if C = ClearCode then    { code is a clear code - so clear }
  438.     begin
  439.       CurrCodeSize := LZWCodeSize + 1;    { reset the code size }
  440.       Slot := EndingCode + 1;                { set slot for next new code }
  441.       TopSlot := 1 shl CurrCodeSize;    { set max slot number }
  442.       while C = ClearCode do
  443.     C := NextCode;    { read until all clear codes gone - shouldn't happen }
  444.       if C = EndingCode then
  445.      Error(geBadCode);       { ending code after a clear code }
  446.       if C >= Slot then { if the code is beyond preset codes then set to zero }
  447.      C := 0;
  448.       OldCode := C;
  449.       DecodeStack[sp] := C;     { output code to decoded stack }
  450.       inc(SP);                    { increment decode stack index }
  451.     end else   { the code is not a clear code or an ending code so it must }
  452.     begin  { be a code code - so decode the code }
  453.       Code := C;
  454.       if Code < Slot then     { is the code in the table? }
  455.       begin
  456.           DecodeCode(Code);                 { decode the code }
  457.           if Slot <= TopSlot then
  458.           begin                           { add the new code to the table }
  459.           Suffix[Slot] := Code;          { make the suffix }
  460.       PreFix[slot] := OldCode;     { the previous code - a link to the data }
  461.       inc(Slot);         { increment slot number }
  462.       OldCode := C;        { set oldcode }
  463.         end;
  464.     if Slot >= TopSlot then         { have reached the top slot for bit size }
  465.     begin                       { increment code bit size }
  466.       if CurrCodeSize < 12 then     { new bit size not too big? }
  467.       begin
  468.         TopSlot := TopSlot shl 1;    { new top slot }
  469.         inc(CurrCodeSize)             { new code size }
  470.           end else
  471.             MaxVal := True;             { Must check next code is a start code }
  472.            end;
  473.       end else
  474.       begin    { the code is not in the table }
  475.         if Code <> Slot then
  476.        Error(geBadCode); { so error out }
  477.     { the code does not exist so make a new entry in the code table
  478.       and then translate the new code }
  479.     TempOldCode := OldCode;  { make a copy of the old code }
  480.     while OldCode > HighCode do     { translate the old code and place it }
  481.     begin                          { on the decode stack }
  482.       DecodeStack[SP] := Suffix[OldCode]; { do the suffix }
  483.       OldCode := Prefix[OldCode];         { get next prefix }
  484.         end;
  485.     DecodeStack[SP] := OldCode;    { put the code onto the decode stack }
  486.                                   { but DO NOT increment stack index }
  487.                             { the decode stack is not incremented because because we are only
  488.                                translating the oldcode to get the first character }
  489.         if Slot <= TopSlot then
  490.     begin     { make new code entry }
  491.       Suffix[Slot] := OldCode;         { first char of old code }
  492.       Prefix[Slot] := TempOldCode;     { link to the old code prefix }
  493.       inc(Slot);                       { increment slot }
  494.         end;
  495.  
  496.     if Slot >= TopSlot then { slot is too big }
  497.     begin                        { increment code size }
  498.       if CurrCodeSize < 12 then
  499.       begin
  500.         TopSlot := TopSlot shl 1;    { new top slot }
  501.             inc(CurrCodeSize);           { new code size }
  502.           end else
  503.             MaxVal := True;             { Must check next code is a start code }
  504.         end;
  505.     DecodeCode(Code); { now that the table entry exists decode it }
  506.     OldCode := C;     { set the new old code }
  507.       end;
  508.     end;
  509.     { the decoded string is on the decode stack so pop it off and put it
  510.       into the line buffer }
  511.     while SP > 0 do
  512.     begin
  513.       dec(SP);
  514.       LineBuffer[CurrBuf] := DecodeStack[SP];
  515.       inc(CurrBuf);
  516.       dec(BufCnt);
  517.       if BufCnt = 0 then  { is the line full ? }
  518.       begin
  519.     CreateLine;
  520.     CurrBuf := 0;
  521.     BufCnt := ImageDescriptor.ImageWidth;
  522.       end;
  523.     end;
  524.     C := NextCode;    { get the next code and go at is some more }
  525.     if (MaxVal = True) and (C <> ClearCode) then
  526.          Error(geBitSizeOverflow);
  527.     MaxVal := False;
  528.   end; { while }
  529. end;
  530.  
  531. {------------------------------------------------------------------------------}
  532.  
  533. procedure TGif.CreateBitHeader;
  534. { This routine takes the values from the GIF image
  535.   descriptor and fills in the appropriate values in the
  536.   bit map header struct. }
  537. begin
  538.   with BmHeader do
  539.   begin
  540.     biSize           := Sizeof(TBitmapInfoHeader);
  541.     biWidth          := ImageDescriptor.ImageWidth;
  542.     biHeight         := ImageDescriptor.ImageHeight;
  543.     biPlanes         := 1;            {Arcane and rarely used}
  544.     biBitCount       := 8;            {Hmmm Should this be hardcoded ?}
  545.     biCompression    := BI_RGB;       {Sorry Did not implement compression in this version}
  546.     biSizeImage      := 0;            {Valid since we are not compressing the image}
  547.     biXPelsPerMeter  :=143;           {Rarely used very arcane field}
  548.     biYPelsPerMeter  :=143;           {Ditto}
  549.     biClrUsed        := 0;            {all colors are used}
  550.     biClrImportant   := 0;            {all colors are important}
  551.   end;
  552. end;
  553.  
  554. {------------------------------------------------------------------------------}
  555.  
  556. {fills in Line list with current line}
  557. procedure TGif.CreateLine;
  558. var
  559.   p: PBmLine;
  560. begin
  561.   Application.ProcessMessages;
  562.   {Create a new bmp line}
  563.   New(p);
  564.   {Fill in the data}
  565.   p^.LineData := LineBuffer;
  566.   p^.LineNo := CurrentY;
  567.   {Add it to the list of lines}
  568.   ImageLines.Add(p);
  569.   {Prepare for the next line}
  570.   Inc(CurrentY);
  571.   if InterLaced then
  572.   { Interlace support }
  573.   begin
  574.     case InterlacePass of
  575.       0: CurrentY := CurrentY + 7;
  576.       1: CurrentY := CurrentY + 7;
  577.       2: CurrentY := CurrentY + 3;
  578.       3: CurrentY := CurrentY + 1;
  579.     end;
  580.     if CurrentY >= ImageDescriptor.ImageHeight then
  581.     begin
  582.       Inc(InterLacePass);
  583.       case InterLacePass of
  584.         1: CurrentY := 4;
  585.         2: CurrentY := 2;
  586.         3: CurrentY := 1;
  587.       end;
  588.     end;
  589.   end;
  590. end;
  591.  
  592. {------------------------------------------------------------------------------}
  593.  
  594. procedure TGif.SaveToStream(Stream: TStream);
  595. var
  596.   BitFile: TBitmapFileHeader;
  597.   i: integer;
  598.   Line: integer;
  599.   ch: char;
  600.   p: PBmLine;
  601.   x: integer;
  602. begin
  603.   with BitFile do begin
  604.      bfSize := (3*255) + Sizeof(TBitmapFileHeader) +  {Color map info}
  605.                      Sizeof(TBitmapInfoHeader) +
  606.       (ImageDescriptor.ImageHeight*ImageDescriptor.ImageWidth);
  607.      bfReserved1 := 0; {not currently used}
  608.      bfReserved2 := 0; {not currently used}
  609.      bfOffBits := (4*256)+ Sizeof(TBitmapFileHeader)+
  610.                            Sizeof(TBitmapInfoHeader);
  611.   end;
  612.   {Write the file header}
  613.   with Stream do begin
  614.     Position:=0;
  615.     ch:='B';
  616.     Write(ch,1);
  617.     ch:='M';
  618.     Write(ch,1);
  619.     Write(BitFile.bfSize,sizeof(BitFile.bfSize));
  620.     Write(BitFile.bfReserved1,sizeof(BitFile.bfReserved1));
  621.     Write(BitFile.bfReserved2,sizeof(BitFile.bfReserved2));
  622.     Write(BitFile.bfOffBits,sizeof(BitFile.bfOffBits));
  623.     {Write the bitmap image header info}
  624.     Write(BmHeader,sizeof(BmHeader));
  625.     {Write the BGR palete inforamtion to this file}
  626.     if UseLocalColors then {Use the local color table}
  627.     begin
  628.       for i:= 0 to 255 do
  629.       begin
  630.         Write(LocalColorTable[i].Blue,1);
  631.         Write(LocalColorTable[i].Green,1);
  632.         Write(LocalColorTable[i].Red,1);
  633.         Write(ch,1); {Bogus palete entry required by windows}
  634.       end;
  635.     end else {Use the global table}
  636.     begin
  637.       for i:= 0 to 255 do
  638.       begin
  639.         Write(GlobalColorTable[i].Blue,1);
  640.         Write(GlobalColorTable[i].Green,1);
  641.         Write(GlobalColorTable[i].Red,1);
  642.         Write(ch,1); {Bogus palete entry required by windows}
  643.       end;
  644.     end;
  645.  
  646.     {Init the Line Counter}
  647.     Line := ImageDescriptor.ImageHeight;
  648.     {Write out File lines in reverse order}
  649.     while Line >= 0 do
  650.     begin
  651.       {Go through the line list in reverse order looking for the
  652.        current Line. Use reverse order since non interlaced gifs are
  653.        stored top to bottom.  Bmp file need to be written bottom to
  654.        top}
  655.       for i := (ImageLines.Count - 1) downto 0  do
  656.       begin
  657.         p := ImageLines.Items[i];
  658.         if p^.LineNo = Line then
  659.         begin
  660.           x := ImageDescriptor.ImageWidth;
  661.           Write(p^.LineData, x);
  662.           ch := chr(0);
  663.           while (x and 3) <> 0 do { Pad up to 4-byte boundary with zeroes }
  664.           begin
  665.             Inc(x);
  666.             Write(ch, 1);
  667.           end;
  668.           break;
  669.         end;
  670.       end;
  671.       Dec(Line);
  672.     end;
  673.     Position:=0; { reset mewmory stream}
  674.   end;
  675. end;
  676.  
  677. {------------------------------------------------------------------------------}
  678.  
  679. initialization
  680.   { register the TGifBitmap as a new graphic file format
  681.     now all the TPicture storage stuff can access our new
  682.     GIF graphic format !
  683.   }
  684.   TPicture.RegisterFileFormat('gif','GIF-Format', TGifBitmap);
  685. end.
  686.  
  687.